perm filename DEFMAC[MAC,LSP]1 blob
sn#447793 filedate 1979-06-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DEFMAC -*-LISP-*-
C00005 00003
C00007 00004
C00010 00005
C00015 00006
C00022 00007
C00025 00008
C00033 00009
C00034 00010
C00037 00011
C00046 ENDMK
C⊗;
;;; DEFMAC -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** DEFUN& and DEFMACRO *********************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(defun cmptime-eval macro (x) (and (eval (cadr x)) (eval (caddr x))))
(cmptime-eval (status feature maclisp)
`(OR (STATUS FEATURE NOLDMSG)
(PROG2 (TERPRI)
(PRINC ',(implode (nconc (exploden '|/Loading DEFMAC |)
(do ((x (exploden
(cond ((caddr (truename infile)))
('/75)))
(cdr x)))
((lessp 47. (car x) 58.)
x))
(exploden '| |)))))))
(DECLARE (*EXPR DEFUN&-ERROR)
(MAPEX T)
(SPECIAL DEFUN&-ERROR)
(SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
(DECLARE (SPECIAL DEFMACRO-CHECK-ARGS ;These are user-settable
DEFMACRO-DISPLACE-CALL ; switches.
DEFMACRO-FOR-COMPILING
MACRO-EXPANSION-USE
GRIND-MACROEXPANDED ))
(DECLARE (*EXPR MACROMEMO MACROFETCH |forget-macromemos/||)
(SPECIAL MACROMEMO MACROEXPANDED))
(EVAL-WHEN (EVAL COMPILE)
(AND (STATUS FEATURE MACLISP)
(NOT (STATUS MACRO /#))
(SETSYNTAX '/#
'MACRO
'(lambda ()
((lambda (data)
(cond ((= data 40.) (macroexpand (read))) ;#(...)
((= (setq data (tyi)) 44.)
(eval (read))) ;#,
((= data 43.)
(or (mapcan '(lambda (x) ;#+(...)
(and (eval `(STATUS FEATURE ,x))
(list 'T)))
(cond ((atom (setq data (read)))
(list data))
(data)))
(read))
(read) )
('t (and (caseq data
((77. 109.)
(not (status feature MACLISP)))
((81. 113.)
(not (status feature LISPM)))
((78. 110.)
(not (status feature NIL)))
(T (break /#-LOSES!)))
(read))
(read) )))
(tyipeek)))))
)
(cmptime-eval (status feature MACLISP)
`(AND (NOT (GET '|forget-macromemos/|| 'SUBR))
(LOAD `(,(car (get 'defmacro 'autoload)) DEFMAX FASL))) )
(COMMENT IF- type macros)
(eval-when (eval compile)
(defun (IF-MACLISP macro) (x)
(and (status feature MACLISP)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NOT-MACLISP macro) (x)
(and (not (status feature MACLISP))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-LISPM macro) (x)
(and (status feature LISPM)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NOT-LISPM macro) (x)
(and (not (status feature LISPM))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NIL macro) (x)
(and (status feature NIL)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NILNIL macro) (x)
(and (status feature NIL)
(not (status feature ITS))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NILINT macro) (x)
(and (status feature NIL)
(status feature ITS)
`(PROGN 'COMPILE ,@(cdr x))))
)
;;; A loop for going down the VARLIST and consing up forms
;;; stops when the tail is at MORE
;;; Requires some variables to be setup - MORE ARGNO
;;; Provides some variables for the body - VARL
;;; Increments ARGNO
(DEFUN MAP-VL MACRO (BODY)
`(DO ((VARL VARLIST (CDR VARL))
(ANSL () (CONS ,(cadr body) ANSL)))
((EQ VARL MORE) ANSL)
(SETQ ARGNO (1+ ARGNO))))
(DEFUN DEFUN&-ERROR () (ERROR '|Bad variable-list syntax -- DEFUN& |
DEFUN&-ERROR))
(COMMENT DEFUN/& for non-MACLISP)
(IF-NOT-MACLISP
(AND (NOT (BOUNDP 'DEFUN/&)) (SETQ DEFUN/& (COPYSYMBOL 'DEFUN/& () )))
(MACRO DEFUN/& (X)
(PROG (NAME VARLIST BODY DEFUN&-ERROR DECLS FLAG VARL)
(SETQ (NAME (NTH 1 X)) (VARLIST (NTH 2 X)) (BODY (CDDDR X)) )
(AND (NOT (ATOM NAME)) (SETQ NAME (CAR NAME)))
(SETQ ARGNO 0)
(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
((MEMQ VARLIST '(MACRO FEXPR))
(ERROR '|Can't DEFUN& for FEXPR or MACRO| (CONS 'DEFUN X))))
(COND ((NULL (SETQ DEFUN&-ERROR VARLIST)) () )
((OR (ATOM VARLIST) (CDR (LAST VARLIST)))
(DEFUN&-ERROR)))
(SETQ VARL VARLIST)
LP1 (COND ((NULL VARL) (RETURN `(DEFUN ,(cdr x)))) ;Simple case
((MEMQ (CAR VARL) '(&OPTIONAL &REST &AUX))
(SETQ FLAG 'T VARL (CDR VARL))
(GO LP1))
('T (OR (SYMBOLP (CAR VARL))
(AND FLAG (NOT (ATOM (CAR VARL))) (SYMBOLP (CAAR VARL)))
(GO LOSE))
(SETQ VARL (CDR VARL))
(GO LP1)))
LOSE (OR (ATOM BODY)
(ATOM (CAR BODY))
(NOT (EQ (CAAR BODY) 'DECLARE))
(SETQ DECLS (LIST (CAR BODY)) BODY (CDR BODY)))
(RETURN
(PROG
(FLAG MORE LETLIST ALLFLATS TMP VARL ARGNO VALUE INSETQS
BOUND-VARS BAD-VARS ALL-LOCALS TEM)
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
(SETQ VARLIST
(MAP-VL
(COND ((ATOM (CAR VARL))
(OR (SYMBOLP (CAR VARL))
(ERROR '|Non-SYMBOL in varlist - DEFUN&|
(CAR VARL)))
(COND ((AND (NULL FLAG)
(MEMQ (CAR VARL)
'(&OPTIONAL &REST &AUX)))
(SETQ FLAG (CAR VARL)))
('T (PUSH (CAR VARL) BAD-VARS)))
(CAR VARL))
(FLAG
(COND ((ATOM (CAAR VARL))
(OR (SYMBOLP (CAAR VARL))
(ERROR '|Non-SYMBOL in varlist - DEFUN&|
(CAAR VARL)))
(PUSH (SETQ TMP (CAAR VARL)) BAD-VARS))
('T (SETQ BAD-VARS
(*&FLATTENSYMS&* (CAAR VARL) BAD-VARS))
(SETQ TMP (GENSYM))))
(SETQ VALUE (CADAR VARL))
(COND ((NOT (|Certify-no-var-dependency/|| VALUE))
(SETQ VALUE 'DEFUN/&)
(SETQ TEM `(DESETQ ,(caar varl) ,tmp))
(PUSH (COND ((NOT (EQ FLAG '&OPTIONAL)) TEM)
(`(AND (EQ ,tmp DEFUN/&) ,tem)))
INSETQS)
(SETQ ALLFLATS (*&FLATTENSYMS&* (CAAR VARL)
ALLFLATS)))
((NOT (ATOM (CAAR VARL)))
(PUSH `(,(caar varl) ,tmp) LETLIST)))
`(,tmp ,value))
('T (SETQ BAD-VARS
(*&FLATTENSYMS&* (CAR VARL) BAD-VARS))
(PUSH `(,(car varl) ,(setq tmp (gensym)))
LETLIST)
TMP))))
(SETQ BODY `((LET (,@(nreverse letlist) ,@allflats)
,@(nreverse insetqs) . ,body)))
(RETURN `(DEFUN ,name ,varlist
,@decls
(COMMENT ARGLIST = ,defun&-error)
. ,body))))))
)
(COMMENT DEFUN/& for MACLISP)
(IF-MACLISP
(DEFUN (DEFUN& MACRO) (X)
(LET ( ( (() NAME VARLIST . BODY) X)
(DCA DEFMACRO-CHECK-ARGS)
(MIN 0) (MAX 262143.) (ARGNO 0) CHECKARGS DEFUN&-ERROR
LEXPRVAR ALLFLATS ALLVARS MORE LETLIST DECLS INSETQS TMP)
(COND ((ATOM NAME))
('T (AND (SETQ TMP (GETL NAME '(DEFMACRO-CHECK-ARGS)))
(SETQ DCA (EVAL (CADR TMP))))
(SETQ NAME (CAR NAME))))
(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
((MEMQ VARLIST '(MACRO FEXPR))
(ERROR '|Can't DEFUN& for FEXPR or MACRO| (CONS 'DEFUN X))))
(COND ((NULL (SETQ DEFUN&-ERROR VARLIST)) () )
((OR (ATOM VARLIST) (CDR (LAST VARLIST)))
(DEFUN&-ERROR)))
(OR (ATOM BODY)
(ATOM (CAR BODY))
(NOT (EQ (CAAR BODY) 'DECLARE))
(SETQ DECLS (LIST (CAR BODY)) BODY (CDR BODY)))
(COND ((SETQ MORE (OR (MEMQ '&OPTIONAL VARLIST) (MEMQ '&REST VARLIST)))
(SETQ LEXPRVAR (GENSYM)
LETLIST (MAP-VL `(,(car varl) (ARG ,argno)))
MIN (LENGTH LETLIST)
MAX (COND ((MEMQ '&REST MORE) () )
((+ MIN (- (LENGTH (CDR MORE))
(LENGTH (MEMQ '&AUX (CDR MORE)))))))
LETLIST (NRECONC LETLIST
(COND ((EQ (POP MORE) '&OPTIONAL)
(|&o-l/|| MORE ARGNO LEXPRVAR))
((|&r-l/|| MORE ARGNO LEXPRVAR))))
VARLIST LEXPRVAR ))
('T (COND ((SETQ MORE (MEMQ '&AUX VARLIST))
(SETQ VARLIST (|copy-til/|| VARLIST MORE))
(SETQ LETLIST (|&a-l/|| (CDR MORE)))))
(SETQ MAX (SETQ MIN (LENGTH VARLIST)))
(COND ((DO L VARLIST (CDR L) (NULL L)
(AND (CAR L) (NOT (SYMBOLP (CAR L))) (RETURN 'T)))
(SETQ VARLIST
(MAPCAR
'(LAMBDA (VAR)
(COND ((OR (NULL VAR) (SYMBOLP VAR)) VAR)
('T (SETQ ALLFLATS (*&FLATTENSYMS&*
(CAR VAR)
ALLFLATS))
(PUSH `(DESETQ ,(car var)
,(setq tmp (gensym)))
INSETQS)
TMP)))
VARLIST) )))))
(MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (DEFUN&-ERROR)))
(SETQ ALLVARS (*&FLATTENSYMS&*
(MAPCAR 'CAR LETLIST)
(COND ((ATOM VARLIST) ALLFLATS)
((*&FLATTENSYMS&* VARLIST ALLFLATS))))))
(COND (LETLIST
(LET ((SVARS (MAPCAN '(LAMBDA (X)
(AND (NOT (ATOM X))
(EQ (CAR X) 'SPECIAL)
(APPEND (CDR X) () )))
(CDAR DECLS)))
(ALL-LOCALS 'T)
(BOUND-VARS)
(BAD-VARS ALLVARS)
(FLAG) )
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
(MAPC '(LAMBDA (Y)
(AND (OR (GET Y 'SPECIAL)
;This clause would allow more extended
; declarations of special variables, by
; adding names on this special list
;(MEMQ Y SPECIAL-VARIABLES)
(MEMQ Y SVARS))
(SETQ ALL-LOCALS () )))
BAD-VARS)
(MAP '(LAMBDA (L)
;Analyze variable dependencies in the left-to-right
;view of the default values for &optionals and &auxs
(COND ((NOT (|Certify-no-var-dependency/|| (CADAR L)))
(SETQ FLAG 'T)
(SETQ ALLFLATS (*&FLATTENSYMS&* (CAAR L)
ALLFLATS))
(PUSH `(DESETQ ,(caar l) ,(cadar l))
INSETQS)
(RPLACA L () ))))
LETLIST)
(AND FLAG (SETQ LETLIST (DELQ () LETLIST))) )))
(COND ((OR ALLFLATS LETLIST)
(SETQ BODY `((LET (,@(nreverse letlist) ,@allflats)
,@(nreverse insetqs) . ,body)))))
(COND ((AND DCA LEXPRVAR)
(SETQ CHECKARGS `(LIST (CONS ',name (LISTIFY ,lexprvar))
',(cons min max)))
(SETQ CHECKARGS
(COND (MAX
(COND ((= 0 MIN)
`(AND (> ,lexprvar ,max)
(ERROR '|Too many arguments supplied |
,checkargs)))
((LET ((MSG `(COND ((> ,lexprvar ,max)
'|Too many arguments supplied |)
('|Too few arguments supplied |))))
(COND ((= MAX MIN)
`(AND (NOT (= ,lexprvar ,max))
(ERROR ,msg ,checkargs)))
(`(AND (OR (< ,lexprvar ,min)
(> ,lexprvar ,max))
(ERROR ,msg ,checkargs))))))))
((NOT (= 0 MIN))
`(AND (< ,lexprvar ,min)
(ERROR '|too few arguments supplied| ,checkargs)))))
(SETQ CHECKARGS (LIST CHECKARGS))))
`(DEFUN ,name ,varlist
,@decls
(COMMENT ARGLIST = ,defun&-error)
,@checkargs
. ,body)))
;REMEMBER! This is still within the IF-MACLISP conditional
;;; Process a varlist that follows an &OPTIONAL.
;;; The remainder may have an &REST and/or and &AUX.
;;; ARGNO is one less than the index number of the argument at
;;; the first of the list
(DEFUN |&o-l/|| (VARLIST ARGNO LEXPRVAR)
(AND (MEMQ '&OPTIONAL VARLIST) (DEFUN&-ERROR))
(LET ((MORE (OR (MEMQ '&REST VARLIST) (MEMQ '&AUX VARLIST))))
(NRECONC
(MAP-VL (COND ((SYMBOLP (CAR VARL))
`(,(car varl) (AND (> ,lexprvar ,(1- argno))
(ARG ,argno))))
((OR (ATOM (CAR VARL))
(ATOM (CDAR VARL))
(CDDAR VARL))
(DEFUN&-ERROR))
(`(,(caar varl) (COND ((> ,lexprvar ,(1- argno))
(ARG ,argno))
(,(cadar varl)))))))
(COND ((NULL MORE) () )
((EQ (POP MORE) '&REST) (|&r-l/|| MORE ARGNO LEXPRVAR))
('T (|&a-l/|| MORE))))))
;;; Process a varlist that follows an &REST.
;;; ARGNO is one less than the index number of argument at the head of the list
(DEFUN |&r-l/|| (VARLIST ARGNO LEXPRVAR)
(COND ((OR (NOT (SYMBOLP (CAR VARLIST)))
(MEMQ (CAR VARLIST) '(() &AUX))
(MEMQ '&REST VARLIST)
(MEMQ '&OPTIONAL VARLIST) )
(DEFUN&-ERROR))
('T (SETQ ARGNO (COND ((= ARGNO 0) `(LISTIFY ,lexprvar))
(`(AND (> ,lexprvar ,argno)
(LISTIFY (- ,argno ,lexprvar))))))
(CONS `(,(car varlist) ,argno)
(COND ((NULL (CDR VARLIST)) () )
((EQ (CADR VARLIST) '&AUX) (|&a-l/|| (CDDR VARLIST)))
((DEFUN&-ERROR)))))))
;;; Process a varlist that follows an &AUX.
(DEFUN |&a-l/|| (VARLIST)
(MAPCAR '(LAMBDA (VAR)
(COND ((MEMQ VAR '(&AUX &REST &OPTIONAL)) (DEFUN&-ERROR))
((SYMBOLP VAR) `(,var () ))
((ATOM VAR) (DEFUN&-ERROR))
(`(,(car var) ,(cadr var))) ))
VARLIST))
)
(COMMENT |Certify-no-var-dependency/||)
(IF-MACLISP
(DEFUN |APPLICABLEP-cnvd/|| MACRO (X) `(GETL ,(cadr x) '(SUBR LSUBR)))
)
(IF-LISPM
(DEFUN |APPLICABLEP-cnvd/|| (X)
(AND (SYMBOLP X)
(SUBRP (FSYMEVAL X))
(NOT (MEMQ X '(COND PROG SETQ OR AND STATUS SSTATUS SIGNP DO PSETQ
ERRSET CATCH *CATCH CATCHALL CATCH-BARRIER )))))
)
(IF-MACLISP
(DEFUN |cnvd-checkautoload/|| (FORM)
(COND ((OR (ATOM FORM) (NOT (SYMBOLP (CAR FORM)))) () )
((AND (GET (CAR FORM) 'AUTOLOAD)
(NOT (GETL (CAR FORM) '(SUBR FSUBR LSUBR MACRO))))
(FUNCALL AUTOLOAD (CONS (CAR FORM) (GET (CAR FORM) 'AUTOLOAD)))
'T)))
)
(IF-NOT-MACLISP
(MACRO |cnvd-checkautoload/|| (FORM) '() )
)
(DEFUN |Certify-no-var-dependency/|| (FORM)
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
; This functions says "yes" if the evaluation of FORM does not depend upon
; any of the variables in BAD-VARS, and where ALL-LOCALS is a flag with
; non-null meaning that there are no special variables in the BAD-VARS
; Requires these three special variables to be bound by the caller:
; BAD-VARS (sart at list of variables for which dependency is checked)
; BOUND-VARS (start at () )
; ALL-LOCALS (start at 'T)
(PROG ()
A (SETQ FORM (MACROEXPAND FORM))
(AND (|cnvd-checkautoload/|| FORM) (GO A))
(COND ((ATOM FORM) ;True iff FORM can be
(RETURN (COND ((NOT (SYMBOLP FORM))) ; guaranteed not have
((MEMQ FORM BOUND-VARS)) ; any free references
((MEMQ FORM BAD-VARS) () ) ; to any variable in
('T)))) ; BAD-VARS
((EQ (CAR FORM) 'QUOTE) (RETURN 'T)))
(AND (COND ((NOT (ATOM (CAR FORM)))
(COND ((EQ (CAAR FORM) 'LAMBDA)
(LET ((BOUND-VARS (APPEND
(COND ((ATOM (CADAR FORM))
(LIST (CADAR FORM)))
((CADAR FORM)))
BOUND-VARS))
(X (CONS 'PROGN (CDDAR FORM))))
(|Certify-no-var-dependency/|| X)))
((LET* ((OX (CAR FORM)) (A (CAR OX)) (D (CDR OX))
(X (MACROEXPAND OX)))
(AND (EQ X OX)
(EQ A (CAR X))
(EQ D (CDR X))
(RETURN () ))
(SETQ FORM (CONS X (CDR FORM)))
(GO A)))))
((MEMQ (CAR FORM) '(FUNCTION *FUNCTION))
(COND ((ATOM (CADR FORM)) (RETURN 'T))
('T (SETQ FORM (CADR FORM)) (GO A))))
((SYMBOLP (CAR FORM))
(COND ((NOT (SYSP (CAR FORM))) () )
((|APPLICABLEP-cnvd/|| (CAR FORM))
(COND ((MEMQ (CAR FORM) '(FUNCALL APPLY MAPC MAP
MAPCON MAPLIST MAPCAR
MAPCAN MAPATOMS *APPLY
MAPF MAPVECTOR
))
(AND (NOT (ATOM (CADR FORM)))
(SYMBOLP (CADADR FORM))
(SYSP (CADADR FORM))))
((MEMQ (CAR FORM) '(EVAL *EVAL READ *READ))
() )
('T)))
((MEMQ (CAR FORM) '(OR AND ERRSET CATCH *CATCH
CATCHALL CATCH-BARRIER
UNWIND-PROTECT )))
((MEMQ (CAR FORM) '(PROG1 PROG2 PROGN PROGV)))
((OR (MEMQ (CAR FORM) '(STATUS SSTATUS SIGNP))
(AND (EQ (CAR FORM) 'DO)
(SYMBOLP (CADR FORM))))
(SETQ FORM (CDR FORM))
'T) )))
(RETURN (|map-cnvd/|| (CDR FORM) 'T)))
(RETURN
(COND ((NOT (SYMBOLP (CAR FORM))) () )
((MEMQ (CAR FORM) '(SETQ PSETQ))
(DO ((Y (CDDR FORM) (CDDR Y)))
((NULL Y) 'T)
(AND (NOT (|Certify-no-var-dependency/|| (CAR Y)))
(RETURN () ))))
((EQ (CAR FORM) 'COND)
(DO ((Y (CDR FORM) (CDR Y)))
((NULL Y) 'T)
(AND (NOT (|map-cnvd/|| (CAR Y) 'T)) (RETURN () ))))
((EQ (CAR FORM) 'PROG)
(LET ((BOUND-VARS (APPEND (CADR FORM) BOUND-VARS)))
(|map-cnvd/|| (CDDR FORM) () )))
((AND (EQ (CAR FORM) 'DO) (OR (NULL (CADR FORM))
(NOT (ATOM (CADR FORM)))))
(LET ((IL (MAPCAR '(LAMBDA (X)
(COND ((ATOM X) (LIST X () () ))
((LIST (CAR X) (CADR X) (CADDR X)))))
(CADR FORM))))
(AND (|map-cnvd/|| (MAPCAR 'CADR IL) 'T)
(LET ((BOUND-VARS (NCONC (MAPCAR 'CAR IL) BOUND-VARS)))
(AND (|map-cnvd/|| (MAPCAR 'CADDR IL) 'T)
(|map-cnvd/|| (CDDDR FORM) () ))))))
((MEMQ (CAR FORM) '(CASEQ TYPECASEQ))
(COND ((NOT (|Certify-no-var-dependency/|| (CADR FORM))) () )
((DO ((Y (CDDR FORM) (CDR Y)))
((NULL Y) 'T)
(AND (NOT (|map-cnvd/|| (CDAR Y) 'T))
(RETURN () ))))))
(ALL-LOCALS (|map-cnvd/|| (CDR FORM) 'T))
;;; If all the BAD-VARS are local, then this line will permit
;;; the use of random functions in FORM, since there can be no
;;; non-lexical variable dependencies.
))))
(DEFUN |map-cnvd/|| (FORM SYMBOLP)
(DO ((Y FORM (CDR Y))) ;Requires two vars to be setup
((NULL Y) 'T) ; BAD-VARS, and BOUND-VARS
(AND (NOT (|Certify-no-var-dependency/|| (CAR Y)))
(OR SYMBOLP (NOT (SYMBOLP (CAR Y))))
(RETURN () ))))
(COMMENT Common auxilliary functions)
;;; Functions on this page needed by both DEFUN& and DEFMACRO
(DEFUN *&FLATTENSYMS&* (X L)
; String together the atoms of an S-EXP into a linear list.
(COND ((ATOM X) (COND ((AND X (SYMBOLP X)) (CONS X L))
(L)))
((*&FLATTENSYMS&* (CAR X) (*&FLATTENSYMS&* (CDR X) L)))))
(DEFUN |copy-til/|| (X Y)
; Copy top level of list x down to the tail of x that is EQ to y
(COND ((OR (NULL X) (EQ X Y)) () )
((CONS (CAR X) (|copy-til/|| (CDR X) Y)))))
;;; The "DEFMACRO" portion of this file must
;;; 1) COMPILE in both QCOMPL and QCMP, and
;;; 2) RUN in both MACLISP and LISPM.
;;; USE CAUTION!!
(IF-NOT-LISPM
;;; Just for starters, consider the case of ((FIND it) 1), where
;;; FIND is a macro s.t. (FIND it) ==> FOO,
(DEFUN (MACRO MACRO) (X)
(LET ((NAME (NTH 1 X)) (DFC DEFMACRO-FOR-COMPILING) TEM)
(COND ((NOT (ATOM NAME))
(SETQ TEM (GETL NAME '(DEFMACRO-FOR-COMPILING))
NAME (CAR NAME))
(AND TEM (SETQ DFC (EVAL (CADR TEM))))))
`(DEFUN ,@(cond (dfc `((,name MACRO)))
('t `(,name MACRO)))
. ,(cddr x))))
)
(DEFUN (|MACRO-macroexpander/|| MACRO) (X)
(LET ((NAMELIST (NTH 1 X))
(BVL (NTH 2 X))
(DFC DEFMACRO-FOR-COMPILING)
NAME FORM)
(SETQ NAME (COND ((ATOM NAMELIST) NAMELIST)
('T (AND (SETQ FORM (GETL NAMELIST
'(DEFMACRO-FOR-COMPILING)))
(SETQ DFC (EVAL (CADR FORM))))
(CAR NAMELIST))))
(SETQ FORM `(MACRO ,namelist ,bvl
(OR (MACROFETCH ,(car bvl))
(MACROMEMO ,(car bvl) (PROGN . ,(cdddr x)) ',name))))
(COND ((NOT DFC) FORM)
(`(PROGN 'COMPILE
#+(MACLISP) (AND (NOT (GET '|forget-macromemos/|| 'SUBR))
(LOAD `(,(car (get 'defmacro 'autoload))
DEFMAX FASL)))
(|forget-macromemos/|| ',name)
,form)))))
(COMMENT DEFMACRO)
(DEFUN (DEFMACRO MACRO) (X) (|defmacro-1/|| X DEFMACRO-DISPLACE-CALL))
(DEFUN (DEFMACRO-DISPLACE MACRO) (X) (|defmacro-1/|| X 'T))
(DEFUN |defmacro-1/|| (X DDC)
(LET ( (NAMELIST (NTH 1 X)) (DEF-ARGLIST (NTH 2 X)) (BODY (CDDDR X))
(MIN 0) (MAX 262143.) (DCA DEFMACRO-CHECK-ARGS)
NAME OPT-ARGLIST OPT-INISL DEFAULTOPTSP RESTARG MACROARG
AUXVARS AUX-INISL ARGLIST ALLFLATS ARGSCHECK TEM BADP )
(COND ((ATOM NAMELIST) (SETQ NAME NAMELIST))
('T (SETQ NAME (CAR NAMELIST))
(AND (SETQ TEM (GETL NAMELIST '(DEFMACRO-CHECK-ARGS)))
(SETQ DCA (EVAL (CADR TEM))))
(AND (SETQ TEM (GETL NAMELIST '(DEFMACRO-DISPLACE-CALL)))
(SETQ DDC (EVAL (CADR TEM))))
(SETQ TEM (GETL NAMELIST '(DEFMACRO-FOR-COMPILING)))
(SETQ NAMELIST
(COND ((NULL TEM) NAME)
((EVAL (CADR TEM))
`(,name DEFMACRO-FOR-COMPILING 'T))
(`(,name DEFMACRO-FOR-COMPILING '() ))))))
(SETQ ARGLIST DEF-ARGLIST)
(COND ((ATOM ARGLIST)
(AND ARGLIST (NOT (SYMBOLP ARGLIST)) (SETQ BADP 'T)))
((CDR (SETQ TEM (LAST ARGLIST)))
(SETQ MIN (LENGTH (SETQ TEM (|copy-til/|| ARGLIST TEM))))
(AND (OR (MEMQ '&OPTIONAL TEM)
(MEMQ '&REST TEM)
(MEMQ '&AUX TEM))
(SETQ BADP 'T)))
((PROG2 (COND ((SETQ TEM (MEMQ '&AUX ARGLIST))
(SETQ AUXVARS (CDR TEM)
ARGLIST (|copy-til/|| ARGLIST TEM))
(MAPC '(LAMBDA (X)
(SETQ ALLFLATS
(COND ((ATOM X) (CONS X ALLFLATS))
('T
(PUSH `(DESETQ ,(car x) ,(cadr x))
AUX-INISL)
(*&FLATTENSYMS&*
(CAR X)
ALLFLATS)))))
AUXVARS)
(SETQ AUX-INISL (NREVERSE AUX-INISL))))
() ))
((SETQ TEM (OR (MEMQ '&OPTIONAL ARGLIST)
(MEMQ '&REST ARGLIST)))
(SETQ ARGLIST (|copy-til/|| ARGLIST TEM)
MIN (LENGTH ARGLIST))
(COND ((EQ (CAR TEM) '&REST)
(AND (OR (NULL (SETQ RESTARG (CADR TEM)))
(NOT (SYMBOLP RESTARG))
(CDDR TEM))
(SETQ BADP 'T)))
('T ;so (EQ (CAR TEM) '&OPTIONAL)
(SETQ OPT-ARGLIST (CDR TEM))
(COND ((MEMQ '&OPTIONAL OPT-ARGLIST) (SETQ BADP 'T))
((SETQ TEM (MEMQ '&REST OPT-ARGLIST))
(SETQ OPT-ARGLIST (|copy-til/|| OPT-ARGLIST TEM))
(AND (OR (NULL (SETQ RESTARG (CADR TEM)))
(NOT (SYMBOLP RESTARG))
(CDDR TEM))
(SETQ BADP 'T)))
('T (SETQ MAX (+ MIN (LENGTH OPT-ARGLIST)))))
(SETQ OPT-ARGLIST
(MAPCAR
'(LAMBDA (X)
(COND ((OR (NULL X) (SYMBOLP X))
(PUSH () OPT-INISL)
X)
('T (SETQ DEFAULTOPTSP 'T)
(AND (OR (ATOM (CDR X)) (CDDR X))
(SETQ BADP 'T))
;( (A . B) (MUMBLEIFY) )
(SETQ ALLFLATS (*&FLATTENSYMS&*
(CAR X)
ALLFLATS))
(PUSH X OPT-INISL)
() )))
OPT-ARGLIST))) )
(SETQ ARGLIST (APPEND ARGLIST OPT-ARGLIST RESTARG)))
('T (SETQ MIN (SETQ MAX (LENGTH ARGLIST)))))
(MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (SETQ BADP 'T)))
(*&FLATTENSYMS&* ARGLIST ALLFLATS))
(AND BADP (ERROR '|Bad argument pattern in use of DEFMACRO| X))
(SETQ MACROARG (IMPLODE (NCONC (EXPLODEN NAME)
(LIST '-)
'(M A C R O A R G))))
(COND ((NOT DCA))
((AND (= MIN 0) (= MAX 262143.)))
((= MIN MAX)
(SETQ ARGSCHECK `(= (LENGTH ,macroarg) ,(1+ min))))
('T (AND (NOT (= MIN 0))
(SETQ ARGSCHECK `(NOT (< (LENGTH ,macroarg) ,(1+ min)))))
(COND ((= MAX 262143.))
('T (SETQ TEM `(NOT (> (LENGTH ,macroarg)
,(1+ max))))
(SETQ ARGSCHECK
(COND ((NULL ARGSCHECK) TEM)
(`(AND ,argscheck ,tem))))))))
(AND ARGSCHECK
(SETQ ARGSCHECK `((AND (NOT ,argscheck)
(ERROR '|Wrong number args to a macro call|
,macroarg)))))
(COND ((NOT (AND OPT-ARGLIST DEFAULTOPTSP)) (SETQ OPT-INISL () ))
((SETQ OPT-INISL ;currently in reverse order
(MAPCAN
'(LAMBDA (X)
(CONS `(SETQ ,macroarg (CDR ,macroarg))
(AND X `((DESETQ ,(car x)
(COND ((NULL ,macroarg) ,(cadr x))
((CAR ,macroarg))))))))
(DO ((L OPT-INISL (CDR L))) ((OR (NULL L) (CAR L)) L))))
(SETQ OPT-INISL (NREVERSE (CDR OPT-INISL)))
(COND ((= MIN 0))
((PUSH `(SETQ ,macroarg (NTHCDR ,min ,macroarg))
OPT-INISL))) ))
`(,(cond (ddc '|MACRO-macroexpander/||) ('MACRO))
,namelist
,@(cond ((and (atom arglist)
(or (null arglist) (null argscheck))
(null allflats)
(null aux-inisl)
(null opt-inisl))
(cond ((null arglist)
`((,macroarg) ,@(and argscheck
`((AND ,macroarg
(ERROR '|No args allowed in macro call|
,macroarg))))
,@body))
(`((,arglist) (SETQ ,arglist (CDR ,arglist)) . ,body))))
(`( (,macroarg)
(COMMENT ARGLIST = ,def-arglist)
,@argscheck
(LET ( (,arglist (SETQ ,macroarg (CDR ,macroarg)))
,@allflats )
,@opt-inisl
,@aux-inisl
,@body))))) ))
ββββ